home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / bit-bash.lisp < prev    next >
Encoding:
Text File  |  1992-08-04  |  18.6 KB  |  519 lines
  1. ;;; -*- Log: code.log; Package: VM -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: bit-bash.lisp,v 1.16 92/07/31 17:50:18 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Functions to implement bit bashing.
  15. ;;;
  16. ;;; Written by William Lott.
  17. ;;;
  18.  
  19. (in-package "VM")
  20.  
  21.  
  22.  
  23. ;;;; Constants and Types.
  24.  
  25.  
  26. (eval-when (compile load eval)
  27.  
  28. (defconstant unit-bits vm:word-bits
  29.   "The number of bits to process at a time.")
  30.  
  31. (defconstant max-bits (ash most-positive-fixnum -2)
  32.   "The maximum number of bits that can be delt with during a single call.")
  33.  
  34.  
  35. (deftype unit ()
  36.   `(unsigned-byte ,unit-bits))
  37.  
  38. (deftype offset ()
  39.   `(integer 0 ,max-bits))
  40.  
  41. (deftype bit-offset ()
  42.   `(integer 0 (,unit-bits)))
  43.  
  44. (deftype bit-count ()
  45.   `(integer 1 (,unit-bits)))
  46.  
  47. (deftype word-offset ()
  48.   `(integer 0 (,(ceiling max-bits unit-bits))))
  49.  
  50.  
  51. ); eval-when
  52.  
  53.  
  54.  
  55. ;;;; Support routines.
  56.  
  57. ;;; A particular implementation must offer either VOPs to translate these, or
  58. ;;; deftransforms to convert them into something supported by the architecture.
  59. ;;;
  60. (macrolet ((frob (name &rest args)
  61.          `(defun ,name ,args
  62.         (,name ,@args))))
  63.   (frob 32bit-logical-not x)
  64.   (frob 32bit-logical-and x y)
  65.   (frob 32bit-logical-or x y)
  66.   (frob 32bit-logical-xor x y)
  67.   (frob 32bit-logical-nor x y)
  68.   (frob 32bit-logical-eqv x y)
  69.   (frob 32bit-logical-nand x y)
  70.   (frob 32bit-logical-andc1 x y)
  71.   (frob 32bit-logical-andc2 x y)
  72.   (frob 32bit-logical-orc1 x y)
  73.   (frob 32bit-logical-orc2 x y))
  74.  
  75.  
  76. (eval-when (compile eval)
  77.   (defmacro byte-order-dispatch (big-endian little-endian)
  78.     (ecase (c:backend-byte-order c:*target-backend*)
  79.       (:big-endian big-endian)
  80.       (:little-endian little-endian))))
  81.  
  82. (defun shift-towards-start (number count)
  83.   "Shift NUMBER by COUNT bits, adding zero bits at the ``end'' and removing
  84.   bits from the ``start.''  On big-endian machines this is a left-shift and
  85.   on little-endian machines this is a right-shift.  Note: only the low 5 bits
  86.   of count are significant."
  87.   (declare (type unit number) (fixnum count))
  88.   (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
  89.     (declare (type bit-offset count))
  90.     (if (zerop count)
  91.     number
  92.     (byte-order-dispatch
  93.      (ash (ldb (byte (- unit-bits count) 0) number) count)
  94.      (ash number (- count))))))
  95.  
  96. (defun shift-towards-end (number count)
  97.   "Shift NUMBER by COUNT bits, adding zero bits at the ``start'' and removing
  98.   bits from the ``end.''  On big-endian machines this is a right-shift and
  99.   on little-endian machines this is a left-shift."
  100.   (declare (type unit number) (fixnum count))
  101.   (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
  102.     (declare (type bit-offset count))
  103.     (if (zerop count)
  104.     number
  105.     (byte-order-dispatch
  106.      (ash number (- count))
  107.      (ash (ldb (byte (- unit-bits count) 0) number) count)))))
  108.  
  109. (proclaim '(inline start-mask end-mask fix-sap-and-offset))
  110. (defun start-mask (count)
  111.   "Produce a mask that contains 1's for the COUNT ``start'' bits and 0's for
  112.   the remaining ``end'' bits.  Only the lower 5 bits of COUNT are significant."
  113.   (declare (fixnum count))
  114.   (shift-towards-start (1- (ash 1 unit-bits)) (- count)))
  115.  
  116. (defun end-mask (count)
  117.   "Produce a mask that contains 1's for the COUNT ``end'' bits and 0's for
  118.   the remaining ``start'' bits.  Only the lower 5 bits of COUNT are
  119.   significant."
  120.   (declare (fixnum count))
  121.   (shift-towards-end (1- (ash 1 unit-bits)) (- count)))
  122.  
  123. (defun fix-sap-and-offset (sap offset)
  124.   "Align the SAP to a word boundry, and update the offset accordingly."
  125.   (declare (type system-area-pointer sap)
  126.        (type index offset)
  127.        (values system-area-pointer index))
  128.   (let ((address (sap-int sap)))
  129.     (values (int-sap (32bit-logical-andc2 address 3))
  130.         (+ (* (logand address 3) byte-bits) offset))))
  131.  
  132. (declaim (inline word-sap-ref %set-word-sap-ref))
  133. ;;;
  134. (defun word-sap-ref (sap offset)
  135.   (declare (type system-area-pointer sap)
  136.        (type index offset)
  137.        (values (unsigned-byte 32))
  138.        (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
  139.   (sap-ref-32 sap (the index (ash offset 2))))
  140. ;;;
  141. (defun %set-word-sap-ref (sap offset value)
  142.   (declare (type system-area-pointer sap)
  143.        (type index offset)
  144.        (type (unsigned-byte 32) value)
  145.        (values (unsigned-byte 32))
  146.        (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
  147.   (setf (sap-ref-32 sap (the index (ash offset 2))) value))
  148. ;;;
  149. (defsetf word-sap-ref %set-word-sap-ref)
  150.  
  151.  
  152.  
  153. ;;;; DO-CONSTANT-BIT-BASH
  154.  
  155. (proclaim '(inline do-constant-bit-bash))
  156. (defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
  157.   "Fill DST with VALUE starting at DST-OFFSET and continuing for LENGTH bits."
  158.   (declare (type offset dst-offset) (type unit value)
  159.        (type function dst-ref-fn dst-set-fn))
  160.   (multiple-value-bind (dst-word-offset dst-bit-offset)
  161.                (floor dst-offset unit-bits)
  162.     (declare (type word-offset dst-word-offset)
  163.          (type bit-offset dst-bit-offset))
  164.     (multiple-value-bind (words final-bits)
  165.              (floor (+ dst-bit-offset length) unit-bits)
  166.       (declare (type word-offset words) (type bit-offset final-bits))
  167.       (if (zerop words)
  168.       (unless (zerop length)
  169.         (funcall dst-set-fn dst dst-word-offset
  170.              (if (= length unit-bits)
  171.              value
  172.              (let ((mask (shift-towards-end (start-mask length)
  173.                             dst-bit-offset)))
  174.                (declare (type unit mask))
  175.                (32bit-logical-or
  176.                 (32bit-logical-and value mask)
  177.                 (32bit-logical-andc2
  178.                  (funcall dst-ref-fn dst dst-word-offset)
  179.                  mask))))))
  180.       (let ((interior (floor (- length final-bits) unit-bits)))
  181.         (unless (zerop dst-bit-offset)
  182.           (let ((mask (end-mask (- dst-bit-offset))))
  183.         (declare (type unit mask))
  184.         (funcall dst-set-fn dst dst-word-offset
  185.              (32bit-logical-or
  186.               (32bit-logical-and value mask)
  187.               (32bit-logical-andc2
  188.                (funcall dst-ref-fn dst dst-word-offset)
  189.                mask))))
  190.           (incf dst-word-offset))
  191.         (dotimes (i interior)
  192.           (funcall dst-set-fn dst dst-word-offset value)
  193.           (incf dst-word-offset))
  194.         (unless (zerop final-bits)
  195.           (let ((mask (start-mask final-bits)))
  196.         (declare (type unit mask))
  197.         (funcall dst-set-fn dst dst-word-offset
  198.              (32bit-logical-or
  199.               (32bit-logical-and value mask)
  200.               (32bit-logical-andc2
  201.                (funcall dst-ref-fn dst dst-word-offset)
  202.                mask)))))))))
  203.   (undefined-value))
  204.  
  205.  
  206. ;;;; DO-UNARY-BIT-BASH
  207.  
  208. (proclaim '(inline do-unary-bit-bash))
  209. (defun do-unary-bit-bash (src src-offset dst dst-offset length
  210.                   dst-ref-fn dst-set-fn src-ref-fn)
  211.   (declare (type offset src-offset dst-offset length)
  212.        (type function dst-ref-fn dst-set-fn src-ref-fn))
  213.   (multiple-value-bind (dst-word-offset dst-bit-offset)
  214.                (floor dst-offset unit-bits)
  215.     (declare (type word-offset dst-word-offset)
  216.          (type bit-offset dst-bit-offset))
  217.     (multiple-value-bind (src-word-offset src-bit-offset)
  218.              (floor src-offset unit-bits)
  219.       (declare (type word-offset src-word-offset)
  220.            (type bit-offset src-bit-offset))
  221.       (cond
  222.        ((<= (+ dst-bit-offset length) unit-bits)
  223.     ;; We are only writing one word, so it doesn't matter what order
  224.     ;; we do it in.  But we might be reading from multiple words, so take
  225.     ;; care.
  226.     (cond
  227.      ((zerop length)
  228.       ;; Actually, we arn't even writing one word.  This is real easy.
  229.       )
  230.      ((= length unit-bits)
  231.       ;; dst-bit-offset must be equal to zero, or we would be writing
  232.       ;; multiple words.  If src-bit-offset is also zero, then we
  233.       ;; just transfer the single word.  Otherwise we have to extract bits
  234.       ;; from two src words.
  235.       (funcall dst-set-fn dst dst-word-offset
  236.            (if (zerop src-bit-offset)
  237.                (funcall src-ref-fn src src-word-offset)
  238.                (32bit-logical-or
  239.             (shift-towards-start
  240.              (funcall src-ref-fn src src-word-offset)
  241.              src-bit-offset)
  242.             (shift-towards-end
  243.              (funcall src-ref-fn src (1+ src-word-offset))
  244.              (- src-bit-offset))))))
  245.      (t
  246.       ;; We are only writing some portion of the dst word, so we need to
  247.       ;; preserve the extra bits.  Also, we still don't know if we need
  248.       ;; one or two source words.
  249.       (let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
  250.         (orig (funcall dst-ref-fn dst dst-word-offset))
  251.         (value
  252.          (if (> src-bit-offset dst-bit-offset)
  253.              ;; The source starts further into the word than does
  254.              ;; the dst, so the source could extend into the next
  255.              ;; word.  If it does, we have to merge the two words,
  256.              ;; and if not, we can just shift the first word.
  257.              (let ((src-bit-shift (- src-bit-offset dst-bit-offset)))
  258.                (if (> (+ src-bit-offset length) unit-bits)
  259.                (32bit-logical-or
  260.                 (shift-towards-start
  261.                  (funcall src-ref-fn src src-word-offset)
  262.                  src-bit-shift)
  263.                 (shift-towards-end
  264.                  (funcall src-ref-fn src (1+ src-word-offset))
  265.                  (- src-bit-shift)))
  266.                (shift-towards-start
  267.                 (funcall src-ref-fn src src-word-offset)
  268.                 src-bit-shift)))
  269.              ;; The dst starts further into the word than does the
  270.              ;; source, so we know the source can not extend into
  271.              ;; a second word (or else the dst would too, and we
  272.              ;; wouldn't be in this branch.
  273.              (shift-towards-end
  274.               (funcall src-ref-fn src src-word-offset)
  275.               (- dst-bit-offset src-bit-offset)))))
  276.         (declare (type unit mask orig value))
  277.         ;; Replace the dst word.
  278.         (funcall dst-set-fn dst dst-word-offset
  279.              (32bit-logical-or
  280.               (32bit-logical-and value mask)
  281.               (32bit-logical-andc2 orig mask)))))))
  282.        ((= src-bit-offset dst-bit-offset)
  283.     ;; The source and dst are aligned, so we don't need to shift
  284.     ;; anything.  But we have to pick the direction of the loop
  285.     ;; in case the source and dst are really the same thing.
  286.     (multiple-value-bind (words final-bits)
  287.                  (floor (+ dst-bit-offset length) unit-bits)
  288.       (declare (type word-offset words) (type bit-offset final-bits))
  289.       (let ((interior (floor (- length final-bits) unit-bits)))
  290.         (declare (type word-offset interior))
  291.         (cond
  292.          ((<= dst-offset src-offset)
  293.           ;; We need to loop from left to right
  294.           (unless (zerop dst-bit-offset)
  295.         ;; We are only writing part of the first word, so mask off the
  296.         ;; bits we want to preserve.
  297.         (let ((mask (end-mask (- dst-bit-offset)))
  298.               (orig (funcall dst-ref-fn dst dst-word-offset))
  299.               (value (funcall src-ref-fn src src-word-offset)))
  300.           (declare (type unit mask orig value))
  301.           (funcall dst-set-fn dst dst-word-offset
  302.                (32bit-logical-or (32bit-logical-and value mask)
  303.                          (32bit-logical-andc2 orig mask))))
  304.         (incf src-word-offset)
  305.         (incf dst-word-offset))
  306.           ;; Just copy the interior words.
  307.           (dotimes (i interior)
  308.         (funcall dst-set-fn dst dst-word-offset
  309.              (funcall src-ref-fn src src-word-offset))
  310.         (incf src-word-offset)
  311.         (incf dst-word-offset))
  312.           (unless (zerop final-bits)
  313.         ;; We are only writing part of the last word.
  314.         (let ((mask (start-mask final-bits))
  315.               (orig (funcall dst-ref-fn dst dst-word-offset))
  316.               (value (funcall src-ref-fn src src-word-offset)))
  317.           (declare (type unit mask orig value))
  318.           (funcall dst-set-fn dst dst-word-offset
  319.                (32bit-logical-or
  320.                 (32bit-logical-and value mask)
  321.                 (32bit-logical-andc2 orig mask))))))
  322.          (t
  323.           ;; We need to loop from right to left.
  324.           (incf dst-word-offset words)
  325.           (incf src-word-offset words)
  326.           (unless (zerop final-bits)
  327.         (let ((mask (start-mask final-bits))
  328.               (orig (funcall dst-ref-fn dst dst-word-offset))
  329.               (value (funcall src-ref-fn src src-word-offset)))
  330.           (declare (type unit mask orig value))
  331.           (funcall dst-set-fn dst dst-word-offset
  332.                (32bit-logical-or
  333.                 (32bit-logical-and value mask)
  334.                 (32bit-logical-andc2 orig mask)))))
  335.           (dotimes (i interior)
  336.         (decf src-word-offset)
  337.         (decf dst-word-offset)
  338.         (funcall dst-set-fn dst dst-word-offset
  339.              (funcall src-ref-fn src src-word-offset)))
  340.           (unless (zerop dst-bit-offset)
  341.         (decf src-word-offset)
  342.         (decf dst-word-offset)
  343.         (let ((mask (end-mask (- dst-bit-offset)))
  344.               (orig (funcall dst-ref-fn dst dst-word-offset))
  345.               (value (funcall src-ref-fn src src-word-offset)))
  346.           (declare (type unit mask orig value))
  347.           (funcall dst-set-fn dst dst-word-offset
  348.                (32bit-logical-or
  349.                 (32bit-logical-and value mask)
  350.                 (32bit-logical-andc2 orig mask))))))))))
  351.        (t
  352.     ;; They arn't aligned.
  353.     (multiple-value-bind (words final-bits)
  354.                  (floor (+ dst-bit-offset length) unit-bits)
  355.       (declare (type word-offset words) (type bit-offset final-bits))
  356.       (let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits))
  357.         (interior (floor (- length final-bits) unit-bits)))
  358.         (declare (type bit-offset src-shift)
  359.              (type word-offset interior))
  360.         (cond
  361.          ((<= dst-offset src-offset)
  362.           ;; We need to loop from left to right
  363.           (let ((prev 0)
  364.             (next (funcall src-ref-fn src src-word-offset)))
  365.         (declare (type unit prev next))
  366.         (flet ((get-next-src ()
  367.              (setf prev next)
  368.              (setf next (funcall src-ref-fn src
  369.                          (incf src-word-offset)))))
  370.           (declare (inline get-next-src))
  371.           (unless (zerop dst-bit-offset)
  372.             (when (> src-bit-offset dst-bit-offset)
  373.               (get-next-src))
  374.             (let ((mask (end-mask (- dst-bit-offset)))
  375.               (orig (funcall dst-ref-fn dst dst-word-offset))
  376.               (value (32bit-logical-or
  377.                   (shift-towards-start prev src-shift)
  378.                   (shift-towards-end next (- src-shift)))))
  379.               (declare (type unit mask orig value))
  380.               (funcall dst-set-fn dst dst-word-offset
  381.                    (32bit-logical-or
  382.                 (32bit-logical-and value mask)
  383.                 (32bit-logical-andc2 orig mask)))
  384.               (incf dst-word-offset)))
  385.           (dotimes (i interior)
  386.             (get-next-src)
  387.             (let ((value (32bit-logical-or
  388.                   (shift-towards-end next (- src-shift))
  389.                   (shift-towards-start prev src-shift))))
  390.               (declare (type unit value))
  391.               (funcall dst-set-fn dst dst-word-offset value)
  392.               (incf dst-word-offset)))
  393.           (unless (zerop final-bits)
  394.             (let ((value
  395.                (if (> (+ final-bits src-shift) unit-bits)
  396.                    (progn
  397.                  (get-next-src)
  398.                  (32bit-logical-or
  399.                   (shift-towards-end next (- src-shift))
  400.                   (shift-towards-start prev src-shift)))
  401.                    (shift-towards-start next src-shift)))
  402.               (mask (start-mask final-bits))
  403.               (orig (funcall dst-ref-fn dst dst-word-offset)))
  404.               (declare (type unit mask orig value))
  405.               (funcall dst-set-fn dst dst-word-offset
  406.                    (32bit-logical-or
  407.                 (32bit-logical-and value mask)
  408.                 (32bit-logical-andc2 orig mask))))))))
  409.          (t
  410.           ;; We need to loop from right to left.
  411.           (incf dst-word-offset words)
  412.           (incf src-word-offset
  413.             (1- (ceiling (+ src-bit-offset length) unit-bits)))
  414.           (let ((next 0)
  415.             (prev (funcall src-ref-fn src src-word-offset)))
  416.         (declare (type unit prev next))
  417.         (flet ((get-next-src ()
  418.                (setf next prev)
  419.                (setf prev (funcall src-ref-fn src
  420.                        (decf src-word-offset)))))
  421.           (declare (inline get-next-src))
  422.           (unless (zerop final-bits)
  423.             (when (> final-bits (- unit-bits src-shift))
  424.               (get-next-src))
  425.             (let ((value (32bit-logical-or
  426.                   (shift-towards-end next (- src-shift))
  427.                   (shift-towards-start prev src-shift)))
  428.               (mask (start-mask final-bits))
  429.               (orig (funcall dst-ref-fn dst dst-word-offset)))
  430.               (declare (type unit mask orig value))
  431.               (funcall dst-set-fn dst dst-word-offset
  432.                    (32bit-logical-or
  433.                 (32bit-logical-and value mask)
  434.                 (32bit-logical-andc2 orig mask)))))
  435.           (decf dst-word-offset)
  436.           (dotimes (i interior)
  437.             (get-next-src)
  438.             (let ((value (32bit-logical-or
  439.                   (shift-towards-end next (- src-shift))
  440.                   (shift-towards-start prev src-shift))))
  441.               (declare (type unit value))
  442.               (funcall dst-set-fn dst dst-word-offset value)
  443.               (decf dst-word-offset)))
  444.           (unless (zerop dst-bit-offset)
  445.             (if (> src-bit-offset dst-bit-offset)
  446.             (get-next-src)
  447.             (setf next prev prev 0))
  448.             (let ((mask (end-mask (- dst-bit-offset)))
  449.               (orig (funcall dst-ref-fn dst dst-word-offset))
  450.               (value (32bit-logical-or
  451.                   (shift-towards-start prev src-shift)
  452.                   (shift-towards-end next (- src-shift)))))
  453.               (declare (type unit mask orig value))
  454.               (funcall dst-set-fn dst dst-word-offset
  455.                    (32bit-logical-or
  456.                 (32bit-logical-and value mask)
  457.                 (32bit-logical-andc2 orig mask)))))))))))))))
  458.   (undefined-value))
  459.  
  460.  
  461. ;;;; The actual bashers.
  462.  
  463. (defun bit-bash-fill (value dst dst-offset length)
  464.   (declare (type unit value) (type offset dst-offset length))
  465.   (locally
  466.    (declare (optimize (speed 3) (safety 0)))
  467.    (do-constant-bit-bash dst dst-offset length value
  468.              #'%raw-bits #'%set-raw-bits)))
  469.  
  470. (defun system-area-fill (value dst dst-offset length)
  471.   (declare (type unit value) (type offset dst-offset length))
  472.   (locally
  473.    (declare (optimize (speed 3) (safety 0)))
  474.    (multiple-value-bind (dst dst-offset)
  475.             (fix-sap-and-offset dst dst-offset)
  476.      (do-constant-bit-bash dst dst-offset length value
  477.                #'word-sap-ref #'%set-word-sap-ref))))
  478.  
  479. (defun bit-bash-copy (src src-offset dst dst-offset length)
  480.   (declare (type offset src-offset dst-offset length))
  481.   (locally
  482.    (declare (optimize (speed 3) (safety 0))
  483.         (inline do-unary-bit-bash))
  484.    (do-unary-bit-bash src src-offset dst dst-offset length
  485.               #'%raw-bits #'%set-raw-bits #'%raw-bits)))
  486.  
  487. (defun system-area-copy (src src-offset dst dst-offset length)
  488.   (declare (type offset src-offset dst-offset length))
  489.   (locally
  490.    (declare (optimize (speed 3) (safety 0)))
  491.    (multiple-value-bind (src src-offset)
  492.             (fix-sap-and-offset src src-offset)
  493.      (declare (type system-area-pointer src))
  494.      (multiple-value-bind (dst dst-offset)
  495.               (fix-sap-and-offset dst dst-offset)
  496.        (declare (type system-area-pointer dst))
  497.        (do-unary-bit-bash src src-offset dst dst-offset length
  498.               #'word-sap-ref #'%set-word-sap-ref
  499.               #'word-sap-ref)))))
  500.  
  501. (defun copy-to-system-area (src src-offset dst dst-offset length)
  502.   (declare (type offset src-offset dst-offset length))
  503.   (locally
  504.    (declare (optimize (speed 3) (safety 0)))
  505.    (multiple-value-bind (dst dst-offset)
  506.             (fix-sap-and-offset dst dst-offset)
  507.      (do-unary-bit-bash src src-offset dst dst-offset length
  508.             #'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
  509.  
  510. (defun copy-from-system-area (src src-offset dst dst-offset length)
  511.   (declare (type offset src-offset dst-offset length))
  512.   (locally
  513.    (declare (optimize (speed 3) (safety 0)))
  514.    (multiple-value-bind (src src-offset)
  515.             (fix-sap-and-offset src src-offset)
  516.      (do-unary-bit-bash src src-offset dst dst-offset length
  517.             #'%raw-bits #'%set-raw-bits #'word-sap-ref))))
  518.   
  519.